home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / link / macsuspend.t < prev    next >
Text File  |  1988-05-02  |  11KB  |  322 lines
  1. (herald macsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define-constant lstate-string-table lstate-text-reloc)
  6.  
  7. (define initial-symbol-count 0)
  8.  
  9. (define (suspend obj out-spec x?)
  10.   (set (experimental?) x?)
  11.   (really-suspend obj out-spec 'o))
  12.  
  13. (define-constant SIZE-OF-HEADERS 140)
  14. (define-constant RELOC-SIZE 10)
  15. (define-constant MAGIC #o520)
  16. (define-constant RELOC #o21)                          
  17. (define-constant TEXT-SYM 0)
  18. (define-constant DATA-SYM 2)
  19.  
  20. (define (vgc-foreign foreign)
  21.   (let* ((heap (lstate-impure *lstate*))
  22.          (addr (+area-frontier heap))
  23.          (name (foreign-name foreign))
  24.          (desc (object nil
  25.                  ((heap-stored self) (lstate-impure *lstate*))
  26.                  ((heap-offset self) addr)
  27.                  ((write-descriptor self stream)
  28.                   (write-data stream (fx+ addr tag/extend)))
  29.                  ((write-store self stream)
  30.                   (write-int stream header/foreign)
  31.                   (write-slot name stream)
  32.                   (write-int stream 0)))))
  33.     (set (+area-frontier heap) (fx+ addr 12))
  34.     (push (+area-objects heap) desc)
  35.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  36.     (generate-slot-relocation name (fx+ addr 4))
  37.     (cymbol-thunk (symbol->string name) 0)
  38.     (reloc-thunk (lstate-symbol-count *lstate*) (fx+ addr 8))
  39.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  40.     desc))
  41.  
  42. (define (generate-slot-relocation obj slot-address)
  43.   (cond ((or (fixnum? obj) (immediate? obj)))
  44.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  45.          (reloc-thunk DATA-SYM slot-address))
  46.         (else
  47.          (reloc-thunk TEXT-SYM slot-address))))
  48.  
  49. (define (text-relocation addr)
  50.   (reloc-thunk TEXT-SYM addr))
  51.  
  52. (define (data-relocation addr)
  53.   (reloc-thunk DATA-SYM addr))
  54.  
  55. (define (reloc-thunk type address)
  56.   (push (lstate-data-reloc *lstate*)
  57.         (cons address type)))
  58.  
  59.  
  60. (define (write-slot obj stream)
  61.   (cond ((fixnum? obj)
  62.          (write-fixnum stream obj))
  63.         ((immediate? obj)
  64.          (write-immediate stream obj))
  65.         ((null? obj)
  66.          (write-descriptor (lstate-null *lstate*) stream))
  67.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  68.          => (lambda (desc) (write-descriptor desc stream)))
  69.         (else
  70.          (error "bad immediate type ~s" obj))))
  71.  
  72. (define-integrable (write-int stream int)
  73.   (write-half stream (fixnum-ashr int 16))
  74.   (write-half stream int))
  75.                        
  76. (define-integrable (write-immediate stream imm)
  77.   (let ((int (descriptor->fixnum imm)))
  78.     (write-half stream (fixnum-ashr int 14))
  79.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  80.                                                      
  81. (define-integrable (write-scratch stream obj i)
  82.   (let ((offset (fixnum-ashl i 2)))
  83.     (write-half stream (mref-16-u obj offset))
  84.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  85.     
  86. (define-integrable (write-half stream int)
  87.   (vm-write-byte stream (fixnum-ashr int 8))
  88.   (vm-write-byte stream int))
  89.  
  90. ;(define-integrable (write-byte stream n)
  91. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  92.  
  93. (define-integrable (write-fixnum stream fixnum)
  94.   (write-half stream (fixnum-ashr fixnum 14))
  95.   (write-half stream (fixnum-ashl fixnum 2)))
  96.  
  97.  
  98.  
  99.  
  100. (define (cymbal-thunk stryng value)
  101.  (push (lstate-symbols *lstate*)
  102.   (object (lambda (stream)                    
  103.             (xcond ((fx<= (string-length stryng) 8)
  104.                     (write-string stream stryng)
  105.                     (do ((i (string-length stryng) (fx+ i 1)))
  106.                         ((fx= i 8))  
  107.                       (write-byte stream 0)))
  108.                    ((table-entry (lstate-string-table *lstate*) stryng)
  109.                     => (lambda (offset)
  110.                          (write-int stream 0)
  111.                          (write-int stream offset))))
  112.             (cond ((fx= value 0)            ; undefined external (foreign)
  113.                    (write-int stream 0)
  114.                    (write-half stream 0)    ; section number
  115.                    (write-half stream 0)    ; type
  116.                    (write-byte stream 2))
  117.                   (else
  118.                    (write-data stream value)
  119.                    (write-half stream 2)    ; section
  120.                    (write-half stream 0)    ; type
  121.                    (write-byte stream 2)))
  122.             (write-byte stream 0))
  123.           ((cymbal-thunk.stryng self) stryng))))
  124.  
  125. (define-operation (cymbal-thunk.stryng thunk))
  126.  
  127.  
  128. (define-integrable (write-data stream int)
  129.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  130.  
  131.  
  132. (define (make-global-cymbol proc name)
  133.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  134.        => (lambda (desc)                                
  135.             (cymbol-thunk (string-downcase! (symbol->string name))
  136.                           desc)))
  137.       (else
  138.        (error "~s not defined" name))))
  139.  
  140.  
  141. (define (write-link-file stream)                 
  142.   (make-global-cymbol big_bang 'big_bang)
  143.   (make-global-cymbol interrupt_dispatcher 'interrupt_dispatcher)
  144.   (write-header     stream)
  145.   (write-text-section-header stream)
  146.   (write-data-section-header stream)
  147.   (write-bss-section-header stream)
  148.   (write-area       stream (lstate-pure *lstate*))
  149.   (write-area       stream (lstate-impure *lstate*))
  150.   (write-relocation stream) 
  151.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  152.  
  153.  
  154. (define (write-header stream)
  155.     (write-half stream MAGIC)                 ;magic number
  156.     (write-half stream 3)                     ; # of sections
  157.     (write-int stream 0)                      ; time and date 
  158.     (write-int stream (cymbal-table-offset))
  159.     (write-int stream (lstate-symbol-count *lstate*))
  160.     (write-half stream 0)                      ; no extra header
  161.     (write-half stream #o1006))                  ; flags
  162.  
  163. (define (write-text-section-header stream)   
  164.   (write-string stream ".text")
  165.   (write-byte stream 0)
  166.   (write-byte stream 0)
  167.   (write-byte stream 0)
  168.   (write-int stream 0)      ; phys addr
  169.   (write-int stream 0)      ; virtual addr
  170.   (write-int stream (lstate-pure-size *lstate*))
  171.   (write-int stream SIZE-OF-HEADERS)
  172.   (write-int stream 0)      ; no reloc
  173.   (write-int stream 0)      ; no line numbers
  174.   (write-half stream 0)      
  175.   (write-half stream 0)      
  176.   (write-int stream #x20))
  177.   
  178. (define (write-data-section-header stream)   
  179.   (write-string stream ".data")
  180.   (write-byte stream 0)
  181.   (write-byte stream 0)
  182.   (write-byte stream 0)
  183.   (write-int stream (lstate-pure-size *lstate*))      ; phys addr
  184.   (write-int stream (lstate-pure-size *lstate*))      ; virtual addr
  185.   (write-int stream (+area-frontier (lstate-impure *lstate*)))
  186.   (write-int stream (+ SIZE-OF-HEADERS (lstate-pure-size *lstate*)))
  187.   (write-int stream (+ SIZE-OF-HEADERS 
  188.                        (lstate-pure-size *lstate*)
  189.                        (+area-frontier (lstate-impure *lstate*))))
  190.   (write-int stream 0)      ; no line numbers
  191.   (write-half stream (length (lstate-data-reloc *lstate*)))
  192.   (write-half stream 0)      
  193.   (write-int stream #x40))
  194.  
  195. (define (write-bss-section-header stream)   
  196.   (write-string stream ".bss")
  197.   (write-byte stream 0)
  198.   (write-byte stream 0)
  199.   (write-byte stream 0)
  200.   (write-byte stream 0)
  201.   (write-int stream (fx+ (+area-frontier (lstate-impure *lstate*))
  202.                          (lstate-pure-size *lstate*)))      ; phys addr
  203.   (write-int stream (fx+ (+area-frontier (lstate-impure *lstate*))
  204.                          (lstate-pure-size *lstate*)))      ; virt addr
  205.   (write-int stream 0)
  206.   (write-int stream 0)
  207.   (write-int stream 0)
  208.   (write-int stream 0)      
  209.   (write-half stream 0)
  210.   (write-half stream 0)      
  211.   (write-int stream #x80))
  212.  
  213. (define (cymbal-table-offset)
  214.   (+ SIZE-OF-HEADERS 
  215.      (lstate-pure-size *lstate*)
  216.      (+area-frontier (lstate-impure *lstate*))
  217.      (* RELOC-SIZE (length (lstate-data-reloc *lstate*)))))
  218.  
  219.  
  220. (define (write-area stream area)
  221.   (walk (lambda (x) (write-store x stream))
  222.         (reverse! (+area-objects area))))
  223.  
  224.  
  225. (define (write-relocation stream)
  226.   (walk (lambda (item)      
  227.           (write-int stream (fx+ (car item) (lstate-pure-size *lstate*)))
  228.           (write-int stream (cdr item))
  229.           (write-half stream #o21))
  230.         (sort-list! (lstate-data-reloc *lstate*)
  231.                     (lambda (x y)      
  232.                        (fx< (car x) (car y))))))
  233.  
  234.   
  235.  
  236. (define  (write-text-and-data-cymbals stream)
  237.     (write-string stream ".text")
  238.     (write-byte stream 0)
  239.     (write-byte stream 0)
  240.     (write-byte stream 0)
  241.     (write-int  stream 0)
  242.     (write-half stream 1)    ; section
  243.     (write-half stream 0)    ; type
  244.     (write-byte stream 3)
  245.     (write-byte stream 1)
  246.  
  247.     (write-int stream (lstate-pure-size *lstate*))
  248.     (write-int stream 0)
  249.     (write-int stream 0)
  250.     (write-int stream 0)
  251.     (write-half stream 0)
  252.  
  253.     (write-string stream ".data")
  254.     (write-byte stream 0)
  255.     (write-byte stream 0)
  256.     (write-byte stream 0)
  257.     (write-int  stream (lstate-pure-size *lstate*))
  258.     (write-half stream 2)    ; section
  259.     (write-half stream 0)    ; type
  260.     (write-byte stream 3)
  261.     (write-byte stream 1)
  262.  
  263.     (write-int stream (+area-frontier (lstate-impure *lstate*)))
  264.     (write-int stream (length (lstate-data-reloc *lstate*)))
  265.     (write-int stream 0)
  266.     (write-int stream 0)
  267.     (write-half stream 0)
  268.  
  269.     (write-string stream ".bss")
  270.     (write-byte stream 0)
  271.     (write-byte stream 0)
  272.     (write-byte stream 0)
  273.     (write-byte stream 0)
  274.     (write-int  stream (fx+ (lstate-pure-size *lstate*) 
  275.                             (+area-frontier (lstate-impure *lstate*))))
  276.     (write-half stream 3)    ; section
  277.     (write-half stream 0)    ; type
  278.     (write-byte stream 3)
  279.     (write-byte stream 1)
  280.  
  281.     (write-int stream 0)
  282.     (write-int stream 0)
  283.     (write-int stream 0)
  284.     (write-int stream 0)
  285.     (write-half stream 0))
  286.  
  287. (define (write-cymbal&stryng-table stream cyms)
  288.   (let ((size (make-stryng-table cyms)))   
  289.     (write-text-and-data-cymbals stream)
  290.     (walk (lambda (cym) (cym stream)) cyms)
  291.     (write-stryng-table stream size cyms)))        
  292.  
  293. (define (make-stryng-table cyms)
  294.   (set (lstate-string-table *lstate*) (make-string-table 'stryngs))
  295.   (iterate loop ((i 4) (cyms cyms))
  296.       (cond ((null? cyms) i)
  297.             (else
  298.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  299.                     (len (string-length string)))
  300.                (cond ((fx<= len 8)
  301.                       (loop i (cdr cyms)))
  302.                      (else                      
  303.                       (set (table-entry (lstate-string-table *lstate*) string)
  304.                i)
  305.                       (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))))
  306.                                                        
  307.  
  308. (define (write-stryng-table stream size cyms)
  309.   (write-int stream size)
  310.   (do ((cyms cyms (cdr cyms)))
  311.       ((null? cyms))
  312.     (let* ((string (cymbal-thunk.stryng (car cyms)))
  313.            (len (string-length string)))
  314.       (cond ((fx<= len 8))
  315.             (else                      
  316.              (write-string stream string)
  317.              (write-byte stream 0))))))
  318.  
  319.  
  320.  
  321.  
  322.